From: Stéphane Glondu Date: Fri, 18 Sep 2026 06:35:16 +0000 (+0200) Subject: New upstream version 6.3.0 X-Git-Tag: archive/raspbian/6.3.0-2+rpi1^2~6^2 X-Git-Url: https://dgit.raspbian.org/%22http://www.example.com/cgi/%22/%22http:/www.example.com/cgi/%22?a=commitdiff_plain;h=a01fd8014922833f62a09de356753b3a437b07f7;p=ocaml-cohttp.git New upstream version 6.3.0 --- diff --git a/.ocamlformat b/.ocamlformat index 291f8a0..d6d27d9 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,4 +1,4 @@ -version=0.27.0 +version=0.29.0 profile=conventional break-infix=fit-or-vertical parse-docstrings=true diff --git a/CHANGES.md b/CHANGES.md index 3371502..475822d 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,3 +1,49 @@ +## v6.3.0 (2026-08-20) + +- cohttp: `Cohttp.Path.resolve_local_file` no longer escapes the docroot when + given percent-encoded traversal sequences such as `..%2f..%2f`. The URI path + is percent-decoded exactly once before `.` and `..` segments are removed. + (#1145 @avsm and Sapphire Livingstone, review by @mdales @edwintorok @patricoferris) + +- cohttp: `Cohttp.Path.resolve_local_file` collapses empty path segments and + drops a trailing slash. A request for `/dir//sub/` now resolves to + `docroot/dir/sub` instead of `docroot/dir//sub/`. (#1145 @avsm) + +- cohttp: Add `Cohttp.Path.normalise`, which converts a request URI into a + relative path that cannot ascend above its root. Servers that make access + control decisions on path segments must apply it to `Request.uri` before + inspecting them, as `Request.uri` does not normalise absolute-form or + percent-encoded targets. (#1145 @avsm) + ```ocaml + let callback _conn req _body = + let uri = Cohttp.Request.uri req in + match String.split_on_char '/' (Cohttp.Path.normalise uri) with + | "admin" :: _ when not (authorised req) -> Server.respond_not_found () + | _ -> + let fname = Cohttp.Path.resolve_local_file ~docroot ~uri in + Server.respond_file ~fname () + ``` + Normalisation is not applied by default, as existing code may depend on the + present semantics, which are safe when not combined with local file + resolution. + +- cohttp-mirage: The static file server normalises the request path of every + request, including directory requests, before looking it up in the mirage-kv + store. Keys are now percent-decoded, so `/my%20file.txt` retrieves the key + `my file.txt` rather than `my%20file.txt` (#1145 @avsm, review by @mdales @edwintorok) + +- cohttp-mirage: The `request_fn` callback receives the request URI unchanged. + A request that falls back to an index page previously received a URI + rewritten to that page. (#1145 @avsm) + +- cohttp: do not add `Transfer-Encoding`/`Content-Length` framing headers to + responses that cannot have a body (1xx, 204 and 304). This fixes WebSocket + handshakes. (@mefyl @avsm, #1141) + +- http: add `Status.body_allowed`, the response-status counterpart to the + existing `Method.body_allowed`, for users constructing responses by hand + (#1141) + ## v6.2.2 (2026-07-26) - cohttp: remove duplicate occurance of lwt in dune-project (@Alizter, #1138) diff --git a/cohttp-async.opam b/cohttp-async.opam index 0052093..aa633d0 100644 --- a/cohttp-async.opam +++ b/cohttp-async.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation for the Async concurrency library" @@ -26,7 +26,7 @@ doc: "https://mirage.github.io/ocaml-cohttp/" bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "dune" {>= "3.8"} - "ocaml" {>= "4.14" & < "5.3.0"} + "ocaml" {>= "4.14"} "http" {= version} "cohttp" {= version} "async_kernel" {>= "v0.17.0"} diff --git a/cohttp-async/bin/cohttp_curl_async.ml b/cohttp-async/bin/cohttp_curl_async.ml index b0903ab..dfca2c6 100644 --- a/cohttp-async/bin/cohttp_curl_async.ml +++ b/cohttp-async/bin/cohttp_curl_async.ml @@ -32,8 +32,8 @@ let make_net_req uri meth' body () = body |> Body.to_pipe |> Pipe.iter ~f:(fun b -> - Stdlib.print_string b; - return ()) + Stdlib.print_string b; + return ()) let _ = (* enable logging to stdout *) diff --git a/cohttp-async/bin/cohttp_server_async.ml b/cohttp-async/bin/cohttp_server_async.ml index 5ecaa22..84ee0d8 100644 --- a/cohttp-async/bin/cohttp_server_async.ml +++ b/cohttp-async/bin/cohttp_server_async.ml @@ -51,13 +51,13 @@ let serve ~info ~docroot ~index uri path = (* Do a directory listing *) Sys.ls_dir file_name >>= Deferred.List.map ~how:`Parallel ~f:(fun f -> - let file_name = file_name / f in - try_with (fun () -> - Unix.stat file_name >>| fun stat -> - (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)) - >>| function - | Ok v -> v - | Error _ -> (None, 0L, f)) + let file_name = file_name / f in + try_with (fun () -> + Unix.stat file_name >>| fun stat -> + (Some stat.Unix.Stats.kind, stat.Unix.Stats.size, f)) + >>| function + | Ok v -> v + | Error _ -> (None, 0L, f)) >>= fun listing -> html_of_listing uri path (sort ((Some `Directory, 0L, "..") :: listing)) diff --git a/cohttp-async/examples/s3_cp.ml b/cohttp-async/examples/s3_cp.ml index 6c5cdbb..1d396e0 100644 --- a/cohttp-async/examples/s3_cp.ml +++ b/cohttp-async/examples/s3_cp.ml @@ -209,8 +209,7 @@ module Auth = struct let canonical_headers = sorted_headers |> List.fold ~init:"" ~f:(fun acc (k, v) -> - acc - ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v)) + acc ^ Printf.sprintf "%s:%s\n" (String.lowercase k) (String.strip v)) in let signed_headers = sorted_headers |> List.map ~f:(fun (k, _) -> k) |> String.concat ~sep:";" diff --git a/cohttp-async/src/client.ml b/cohttp-async/src/client.ml index b8f805b..d52c552 100644 --- a/cohttp-async/src/client.ml +++ b/cohttp-async/src/client.ml @@ -20,19 +20,21 @@ module Net = struct let connect_uri ?interrupt ?ssl_config uri = (match Uri.scheme uri with - | Some "httpunix" -> - let host = Uri.host_with_default ~default:"localhost" uri in - return @@ `Unix_domain_socket host - | _ -> ( - lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> - return - @@ - match (Uri.scheme uri, ssl_config) with - | Some "https", Some config -> `OpenSSL (addr, port, config) - | Some "https", None -> - let config = Conduit_async.V2.Ssl.Config.create ~hostname:host () in - `OpenSSL (addr, port, config) - | _ -> `TCP (addr, port))) + | Some "httpunix" -> + let host = Uri.host_with_default ~default:"localhost" uri in + return @@ `Unix_domain_socket host + | _ -> ( + lookup uri |> Deferred.Or_error.ok_exn >>= fun (host, addr, port) -> + return + @@ + match (Uri.scheme uri, ssl_config) with + | Some "https", Some config -> `OpenSSL (addr, port, config) + | Some "https", None -> + let config = + Conduit_async.V2.Ssl.Config.create ~hostname:host () + in + `OpenSSL (addr, port, config) + | _ -> `TCP (addr, port))) >>= fun mode -> Conduit_async.V2.connect ?interrupt mode >>| fun (r, w) -> (Input_channel.create r, w) @@ -134,22 +136,23 @@ let call ?interrupt ?ssl_config ?headers ?(chunked = false) ?(body = `Empty) (* Create a request, then make the request. Figure out an appropriate transfer encoding *) (match chunked with - | false -> - Body.Private.disable_chunked_encoding body >>| fun (body, body_length) -> - ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri, - body ) - | true -> - Deferred.return - (match Body.is_empty body with - | `True -> - (* Don't used chunked encoding with an empty body *) - ( Cohttp.Request.make_for_client ?headers ~chunked:false - ~body_length:0L meth uri, - body ) - | `Unknown | `False -> - (* Use chunked encoding if there is a body *) - ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri, - body ))) + | false -> + Body.Private.disable_chunked_encoding body + >>| fun (body, body_length) -> + ( Cohttp.Request.make_for_client ?headers ~chunked ~body_length meth uri, + body ) + | true -> + Deferred.return + (match Body.is_empty body with + | `True -> + (* Don't used chunked encoding with an empty body *) + ( Cohttp.Request.make_for_client ?headers ~chunked:false + ~body_length:0L meth uri, + body ) + | `Unknown | `False -> + (* Use chunked encoding if there is a body *) + ( Cohttp.Request.make_for_client ?headers ~chunked:true meth uri, + body ))) >>= fun (req, body) -> request ?interrupt ?ssl_config ~body ~uri req let get ?interrupt ?ssl_config ?headers uri = diff --git a/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml index 7215983..3673c2d 100644 --- a/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml +++ b/cohttp-async/test/cohttp_async_test/src/cohttp_async_test.ml @@ -50,19 +50,17 @@ let test_server_s ?port ?(name = "Cohttp Server Test") spec f = let results = tests |> Deferred.List.map ~how:`Sequential ~f:(fun (name, test) -> - Logs.debug (fun m -> m "Running %s" name); - let res = - try_with test >>| function - | Ok () -> `Ok - | Error exn -> `Exn exn - in - res >>| fun res -> (name, res)) + Logs.debug (fun m -> m "Running %s" name); + let res = + try_with test >>| function Ok () -> `Ok | Error exn -> `Exn exn + in + res >>| fun res -> (name, res)) in results >>| fun results -> let ounit_tests = results |> List.map ~f:(fun (name, res) -> - name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) + name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) in name >::: ounit_tests) diff --git a/cohttp-async/test/test_async_integration.ml b/cohttp-async/test/test_async_integration.ml index a2cfb9a..12363b9 100644 --- a/cohttp-async/test/test_async_integration.ml +++ b/cohttp-async/test/test_async_integration.ml @@ -82,9 +82,9 @@ let ts = responses |> Pipe.to_list >>= fun resps -> resps |> Deferred.List.iter ~how:`Sequential ~f:(fun (_resp, body) -> - let expected_body = body_q |> Queue.dequeue_exn in - body |> Body.to_string >>| fun body -> - assert_equal ~printer expected_body body) + let expected_body = body_q |> Queue.dequeue_exn in + body |> Body.to_string >>| fun body -> + assert_equal ~printer expected_body body) in let large_chunked_response () = Client.get ~headers uri >>= fun (resp, body) -> diff --git a/cohttp-bench.opam b/cohttp-bench.opam index 9e5bdf8..48c170c 100644 --- a/cohttp-bench.opam +++ b/cohttp-bench.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Benchmarks binaries for Cohttp" diff --git a/cohttp-curl-async.opam b/cohttp-curl-async.opam index 5f8dc54..c05ebd7 100644 --- a/cohttp-curl-async.opam +++ b/cohttp-curl-async.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Cohttp client using Curl & Async as the backend" @@ -22,7 +22,7 @@ doc: "https://mirage.github.io/ocaml-cohttp/" bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "dune" {>= "3.8"} - "ocurl" {>= "0.9.2"} + "curl" {>= "0.10.0"} "http" {= version} "stringext" "cohttp-curl" {= version} diff --git a/cohttp-curl-async/src/cohttp_curl_async.ml b/cohttp-curl-async/src/cohttp_curl_async.ml index ef41336..dd48828 100644 --- a/cohttp-curl-async/src/cohttp_curl_async.ml +++ b/cohttp-curl-async/src/cohttp_curl_async.ml @@ -74,9 +74,9 @@ module Context = struct (fun () -> f ()) () |> Deferred.map ~f:(function - | `Bad_fd | `Closed -> assert false - | `Unsupported -> assert false - | `Interrupted -> ()) + | `Bad_fd | `Closed -> assert false + | `Unsupported -> assert false + | `Interrupted -> ()) |> Deferred.ignore_m in don't_wait_for event; diff --git a/cohttp-curl-lwt.opam b/cohttp-curl-lwt.opam index 735ad62..605ab5b 100644 --- a/cohttp-curl-lwt.opam +++ b/cohttp-curl-lwt.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Cohttp client using Curl & Lwt as the backend" @@ -23,7 +23,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "dune" {>= "3.8"} "ocaml" {>= "4.08"} - "ocurl" {>= "0.9.2"} + "curl" {>= "0.10.0"} "http" {= version} "cohttp-curl" {= version} "stringext" diff --git a/cohttp-curl-lwt/src/cohttp_curl_lwt.ml b/cohttp-curl-lwt/src/cohttp_curl_lwt.ml index e856024..e75a6ad 100644 --- a/cohttp-curl-lwt/src/cohttp_curl_lwt.ml +++ b/cohttp-curl-lwt/src/cohttp_curl_lwt.ml @@ -40,11 +40,10 @@ module Context = struct let unregister t curl = Curl.get_activesocket curl |> Option.iter (fun fd -> - match Hashtbl.find_opt t.by_fd fd with - | None -> () - | Some curls -> - Hashtbl.replace t.by_fd fd - (List.filter (fun c -> c = curl) curls)); + match Hashtbl.find_opt t.by_fd fd with + | None -> () + | Some curls -> + Hashtbl.replace t.by_fd fd (List.filter (fun c -> c = curl) curls)); Curl.Multi.remove t.mt curl; Hashtbl.remove t.wakeners curl diff --git a/cohttp-curl.opam b/cohttp-curl.opam index be347e1..8a23482 100644 --- a/cohttp-curl.opam +++ b/cohttp-curl.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Shared code between the individual cohttp-curl clients" @@ -21,7 +21,7 @@ bug-reports: "https://github.com/mirage/ocaml-cohttp/issues" depends: [ "dune" {>= "3.8"} "ocaml" {>= "4.08"} - "ocurl" {>= "0.9.2"} + "curl" {>= "0.10.0"} "http" {= version} "stringext" "odoc" {with-doc} diff --git a/cohttp-eio.opam b/cohttp-eio.opam index 1f51b0f..b77edac 100644 --- a/cohttp-eio.opam +++ b/cohttp-eio.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation with eio backend" diff --git a/cohttp-eio/src/server.ml b/cohttp-eio/src/server.ml index b1b2fe6..5154324 100644 --- a/cohttp-eio/src/server.ml +++ b/cohttp-eio/src/server.ml @@ -2,7 +2,7 @@ open Utils module IO = Io.IO type body = Body.t -type conn = IO.conn * Cohttp.Connection.t [@@warning "-3"] +type conn = IO.conn * Cohttp.Connection.t type writer = Http.Request.t * IO.oc type response = writer -> unit diff --git a/cohttp-eio/tests/test_forward_proxy.ml b/cohttp-eio/tests/test_forward_proxy.ml index da2eda9..e31bbf5 100644 --- a/cohttp-eio/tests/test_forward_proxy.ml +++ b/cohttp-eio/tests/test_forward_proxy.ml @@ -109,8 +109,7 @@ let () = https://www.rfc-editor.org/rfc/rfc2606 *) let uri = Uri.of_string "http://foo.invalid" in match Cohttp_eio.Client.get ~sw client uri with - | exception Failure _ - | exception Eio.Io (Eio.Net.E _, _) -> + | (exception Failure _) | (exception Eio.Io (Eio.Net.E _, _)) -> (* This should fail, since we are not using the proxy *) () | unexepcted_resp, _ -> diff --git a/cohttp-lwt-jsoo.opam b/cohttp-lwt-jsoo.opam index f4b8a2d..cd2446b 100644 --- a/cohttp-lwt-jsoo.opam +++ b/cohttp-lwt-jsoo.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation for the Js_of_ocaml JavaScript compiler" diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml index 8f1644f..8dee689 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.ml @@ -273,15 +273,15 @@ module Make_client_async (P : Params) = Make_api (struct (* perform call *) (match body with - | None -> Lwt.return xml##(send Js.null) - | Some body -> - CLB.to_string body >>= fun body -> - let bs = binary_string body in - (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) + | None -> Lwt.return xml##(send Js.null) + | Some body -> + CLB.to_string body >>= fun body -> + let bs = binary_string body in + (*Js.Opt.case (File.CoerceTo.blob (Obj.magic blob)) (fun () -> failwith "could not coerce to blob") (fun blob -> Lwt.return (xml##(send_blob blob)))*) - (*Lwt.return (xml##send (Js.Opt.return bs)) *) - Lwt.return (xml##send (Js.Opt.return (Obj.magic bs)))) + (*Lwt.return (xml##send (Js.Opt.return bs)) *) + Lwt.return (xml##send (Js.Opt.return (Obj.magic bs)))) >>= fun () -> Lwt.on_cancel res (fun () -> xml##abort); (* unwrap the response *) @@ -321,11 +321,11 @@ module Make_client_sync (P : Params) = Make_api (struct in (* perform call *) (match body with - | None -> Lwt.return xml##(send Js.null) - | Some body -> - CLB.to_string body >|= fun body -> - let bs = binary_string body in - xml##(send (Js.Opt.return (Obj.magic bs)))) + | None -> Lwt.return xml##(send Js.null) + | Some body -> + CLB.to_string body >|= fun body -> + let bs = binary_string body in + xml##(send (Js.Opt.return (Obj.magic bs)))) >>= fun _body -> let body = Bb.construct_body xml in (* (re-)construct the response *) diff --git a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli index 0abfc09..e9dbe06 100644 --- a/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli +++ b/cohttp-lwt-jsoo/src/cohttp_lwt_jsoo.mli @@ -22,8 +22,8 @@ custom reporter or use: {[ - let reporter = Logs_browser.console_reporter () in - Logs.set_reporter reporter + let reporter = Logs_browser.console_reporter () in + Logs.set_reporter reporter ]} *) (** Configuration parameters for the XmlHttpRequest engines *) diff --git a/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml b/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml index e99b72a..3d4bae4 100644 --- a/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml +++ b/cohttp-lwt-jsoo/test/src/cohttp_lwt_jsoo_test.ml @@ -18,17 +18,17 @@ let promise_of_lwt lwt = let () = Js.export_all - (object%js - method request uri = - let f () = - let uri = Uri.of_string (Js.to_string uri) in - let* response, body = Client.get uri in - let+ body = Cohttp_lwt.Body.to_string body in - let status = - Http.Response.status response |> Cohttp.Code.code_of_status - in - Js.array - [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |] - in - promise_of_lwt f - end) + object%js + method request uri = + let f () = + let uri = Uri.of_string (Js.to_string uri) in + let* response, body = Client.get uri in + let+ body = Cohttp_lwt.Body.to_string body in + let status = + Http.Response.status response |> Cohttp.Code.code_of_status + in + Js.array + [| Js.Unsafe.inject status; Js.Unsafe.inject @@ Js.string body |] + in + promise_of_lwt f + end diff --git a/cohttp-lwt-unix-bin.opam b/cohttp-lwt-unix-bin.opam index 711dfce..2538a47 100644 --- a/cohttp-lwt-unix-bin.opam +++ b/cohttp-lwt-unix-bin.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Command-line utilities shipped with cohttp-lwt-unix" diff --git a/cohttp-lwt-unix.opam b/cohttp-lwt-unix.opam index 2e970d2..52a6bee 100644 --- a/cohttp-lwt-unix.opam +++ b/cohttp-lwt-unix.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation for Unix and Windows using Lwt" diff --git a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml index 72cadaf..d9fdab2 100644 --- a/cohttp-lwt-unix/bin/cohttp_server_lwt.ml +++ b/cohttp-lwt-unix/bin/cohttp_server_lwt.ml @@ -55,16 +55,15 @@ let serve ~info ~docroot ~index uri path = | false -> ls_dir file_name >>= Lwt_list.map_s (fun f -> - let file_name = file_name / f in - Lwt.try_bind - (fun () -> Lwt_unix.LargeFile.stat file_name) - (fun stat -> - Lwt.return - ( Some - (kind_of_unix_kind stat.Unix.LargeFile.st_kind), - stat.Unix.LargeFile.st_size, - f )) - (fun _exn -> Lwt.return (None, 0L, f))) + let file_name = file_name / f in + Lwt.try_bind + (fun () -> Lwt_unix.LargeFile.stat file_name) + (fun stat -> + Lwt.return + ( Some (kind_of_unix_kind stat.Unix.LargeFile.st_kind), + stat.Unix.LargeFile.st_size, + f )) + (fun _exn -> Lwt.return (None, 0L, f))) >>= fun listing -> let body = html_of_listing uri path (sort listing) info in Server.respond_string ~status:`OK ~body ()) diff --git a/cohttp-lwt-unix/examples/client_lwt_proxy.ml b/cohttp-lwt-unix/examples/client_lwt_proxy.ml index 0293003..36f6269 100644 --- a/cohttp-lwt-unix/examples/client_lwt_proxy.ml +++ b/cohttp-lwt-unix/examples/client_lwt_proxy.ml @@ -103,8 +103,8 @@ let main ~proxy ~uri ~credential () = getenv_opt "http_proxy"; ] |> List.filter_map (function - | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v) - | n -> n) ) + | Some (k, v) -> Some (String.(sub k 0 (rindex k '_')), v) + | n -> n) ) | v -> (v, None, []) in diff --git a/cohttp-lwt-unix/src/debug.mli b/cohttp-lwt-unix/src/debug.mli index d14e712..447a5cc 100644 --- a/cohttp-lwt-unix/src/debug.mli +++ b/cohttp-lwt-unix/src/debug.mli @@ -22,9 +22,9 @@ val default_reporter : Logs.reporter stderr, using coloured output if possible. {[ - Fmt_tty.setup_std_outputs (); - Logs.set_level ~all:true (Some level); - Logs.set_reporter Debug.default_reporter + Fmt_tty.setup_std_outputs (); + Logs.set_level ~all:true (Some level); + Logs.set_reporter Debug.default_reporter ]} *) val activate_debug : unit -> unit @@ -41,12 +41,12 @@ val debug_active : unit -> bool over the various modules logs names as follows. {[ - (* Set log level v for all loggers, this does also affect cohttp internal loggers *) - Logs.set_level ~all:true level; - (* Disable all cohttp-lwt and cohttp-lwt-unix logs *) - List.iter (fun src -> - match Logs.Src.name src with - | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None - | _ -> ()) - @@ Logs.Src.list () + (* Set log level v for all loggers, this does also affect cohttp internal loggers *) + Logs.set_level ~all:true level; + (* Disable all cohttp-lwt and cohttp-lwt-unix logs *) + List.iter (fun src -> + match Logs.Src.name src with + | "cohttp.lwt.io" | "cohttp.lwt.server" -> Logs.Src.set_level src None + | _ -> ()) + @@ Logs.Src.list () ]} *) diff --git a/cohttp-lwt-unix/src/server.mli b/cohttp-lwt-unix/src/server.mli index e3643e5..d4c2824 100644 --- a/cohttp-lwt-unix/src/server.mli +++ b/cohttp-lwt-unix/src/server.mli @@ -33,7 +33,7 @@ val create : To create a simple HTTP server listening on port 8089: {[ - let run = create (`TCP 8080) + let run = create (`TCP 8080) ]} When provided, the [stop] thread will terminate the server if it ever diff --git a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml index d399ea1..096f32a 100644 --- a/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml +++ b/cohttp-lwt-unix/test/cohttp_lwt_unix_test/src/cohttp_lwt_unix_test.ml @@ -52,19 +52,19 @@ let test_server_s ?port ?(name = "Cohttp Server Test") spec f = let results = tests |> Lwt_list.map_s (fun (name, test) -> - Logs.info (fun f -> f "Running %s" name); - let res = - Lwt.try_bind test - (fun () -> return `Ok) - (fun exn -> return (`Exn exn)) - in - res >|= fun res -> (name, res)) + Logs.info (fun f -> f "Running %s" name); + let res = + Lwt.try_bind test + (fun () -> return `Ok) + (fun exn -> return (`Exn exn)) + in + res >|= fun res -> (name, res)) in results >|= fun results -> let ounit_tests = results |> List.map (fun (name, res) -> - name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) + name >:: fun () -> match res with `Ok -> () | `Exn x -> raise x) in name >::: ounit_tests) diff --git a/cohttp-lwt-unix/test/test_client.ml b/cohttp-lwt-unix/test/test_client.ml index 47d7f6e..f3462e2 100644 --- a/cohttp-lwt-unix/test/test_client.ml +++ b/cohttp-lwt-unix/test/test_client.ml @@ -21,27 +21,29 @@ let test_server tests = let uri = Request.uri req in let path = Uri.path uri in (match Request.meth req with - | `PUT -> - let status = if Hashtbl.mem store path then `Created else `No_content in - Hashtbl.replace store path body; - Server.respond_string ~status ~body:"" () - | `DELETE -> - if Hashtbl.mem store path then ( - Hashtbl.remove store path; - Server.respond_string ~status:`No_content ~body:"" ()) - else Server.respond_not_found ~uri () - | `HEAD -> - if Hashtbl.mem store path then - Server.respond_string ~body:"" ~status:`OK () - else Server.respond_string ~body:"" ~status:`Not_found () - | `GET -> ( - match Hashtbl.find_opt store path with - | Some body -> Server.respond_string ~status:`OK ~body () - | None -> Server.respond_not_found ~uri ()) - | meth -> - Server.respond_string ~status:`Method_not_allowed - ~body:("Unsupported method " ^ Code.string_of_method meth) - ()) + | `PUT -> + let status = + if Hashtbl.mem store path then `Created else `No_content + in + Hashtbl.replace store path body; + Server.respond_string ~status ~body:"" () + | `DELETE -> + if Hashtbl.mem store path then ( + Hashtbl.remove store path; + Server.respond_string ~status:`No_content ~body:"" ()) + else Server.respond_not_found ~uri () + | `HEAD -> + if Hashtbl.mem store path then + Server.respond_string ~body:"" ~status:`OK () + else Server.respond_string ~body:"" ~status:`Not_found () + | `GET -> ( + match Hashtbl.find_opt store path with + | Some body -> Server.respond_string ~status:`OK ~body () + | None -> Server.respond_not_found ~uri ()) + | meth -> + Server.respond_string ~status:`Method_not_allowed + ~body:("Unsupported method " ^ Code.string_of_method meth) + ()) >|= Cohttp_lwt_unix_test.response in Cohttp_lwt_unix_test.test_server_s ~name:"mutable resources" spec tests diff --git a/cohttp-lwt-unix/test/test_sanity.ml b/cohttp-lwt-unix/test/test_sanity.ml index 5c8202f..0dddcd8 100644 --- a/cohttp-lwt-unix/test/test_sanity.ml +++ b/cohttp-lwt-unix/test/test_sanity.ml @@ -38,13 +38,13 @@ let server = (); ] @ List.init (leak_repeat * 2) (fun i _ _ -> - (* no leaks *) - if i mod 2 = 0 then - Server.respond_string ~status:`OK ~body:"" () >|= fun rsp -> - `Response rsp - else - Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp -> - `Response rsp) + (* no leaks *) + if i mod 2 = 0 then + Server.respond_string ~status:`OK ~body:"" () >|= fun rsp -> + `Response rsp + else + Server.respond_string ~status:`OK ~body:"no leak" () >|= fun rsp -> + `Response rsp) (* pipelined_expert *) @ [ (fun _ _ -> diff --git a/cohttp-lwt-unix/test/test_sanity_noisy.ml b/cohttp-lwt-unix/test/test_sanity_noisy.ml index e54b83c..0e07bc5 100644 --- a/cohttp-lwt-unix/test/test_sanity_noisy.ml +++ b/cohttp-lwt-unix/test/test_sanity_noisy.ml @@ -45,8 +45,7 @@ let ts_noisy = Client.get ~ctx uri >>= fun (resp, body) -> assert_equal (Response.status resp) `Not_modified; let headers = Response.headers resp in - assert_equal ~printer:Transfer.string_of_encoding - Transfer.(Fixed 0L) + assert_equal ~printer:Transfer.string_of_encoding Transfer.Unknown (Header.get_transfer_encoding headers); body |> Body.is_empty >|= fun is_empty -> assert_bool "No body returned when not modified" is_empty diff --git a/cohttp-lwt.opam b/cohttp-lwt.opam index cffc3ea..89b0455 100644 --- a/cohttp-lwt.opam +++ b/cohttp-lwt.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation using the Lwt concurrency library" diff --git a/cohttp-lwt/src/connection.ml b/cohttp-lwt/src/connection.ml index 0c454a7..0a53dcf 100644 --- a/cohttp-lwt/src/connection.ml +++ b/cohttp-lwt/src/connection.ml @@ -203,18 +203,18 @@ module Make (Net : S.Net) : S.Connection with module Net = Net = struct (* select encoding based on (1st) header or (2nd) body *) (match Header.get_transfer_encoding headers with - | Unknown -> ( - match Body.transfer_encoding body with - | Fixed _ as e -> Lwt.return (e, body) - | Chunked as e when connection.persistent = `True -> - Lwt.return (e, body) - | Chunked (* connection.persistent <> `True *) -> - (* We don't know yet whether chunked encoding is supported. - * Therefore use fixed length encoding. *) - Body.length body >>= fun (length, body) -> - Lwt.return (Cohttp.Transfer.Fixed length, body) - | Unknown -> assert false) - | e -> Lwt.return (e, body)) + | Unknown -> ( + match Body.transfer_encoding body with + | Fixed _ as e -> Lwt.return (e, body) + | Chunked as e when connection.persistent = `True -> + Lwt.return (e, body) + | Chunked (* connection.persistent <> `True *) -> + (* We don't know yet whether chunked encoding is supported. + * Therefore use fixed length encoding. *) + Body.length body >>= fun (length, body) -> + Lwt.return (Cohttp.Transfer.Fixed length, body) + | Unknown -> assert false) + | e -> Lwt.return (e, body)) >>= fun (encoding, body) -> let headers = if diff --git a/cohttp-lwt/src/connection_cache.ml b/cohttp-lwt/src/connection_cache.ml index 09c803d..822b04d 100644 --- a/cohttp-lwt/src/connection_cache.ml +++ b/cohttp-lwt/src/connection_cache.ml @@ -23,8 +23,8 @@ module Make_no_cache (Connection : S.Connection) = struct (fun () -> res >>= fun (_, body) -> (match body with - | `Empty | `String _ | `Strings _ -> Lwt.return_unit - | `Stream stream -> Lwt_stream.closed stream) + | `Empty | `String _ | `Strings _ -> Lwt.return_unit + | `Stream stream -> Lwt_stream.closed stream) >>= fun () -> Connection.close connection; Lwt.return_unit) @@ -301,11 +301,11 @@ end = struct let call self ?headers ?body ?absolute_form meth uri = (match self.proxy_endp with - | None -> - Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp -> - self.proxy_endp <- Some proxy_endp; - Lwt.return proxy_endp - | Some proxy_endp -> Lwt.return proxy_endp) + | None -> + Net.resolve ~ctx:self.ctx self.proxy_uri >>= fun proxy_endp -> + self.proxy_endp <- Some proxy_endp; + Lwt.return proxy_endp + | Some proxy_endp -> Lwt.return proxy_endp) >>= fun proxy_endp -> let remote_port = match Uri_services.tcp_port_of_uri uri with diff --git a/cohttp-lwt/src/s.ml b/cohttp-lwt/src/s.ml index 55d7199..0f52a68 100644 --- a/cohttp-lwt/src/s.ml +++ b/cohttp-lwt/src/s.ml @@ -99,8 +99,8 @@ type call = follows in [cohttp-lwt-unix] {[ - Cohttp_lwt_unix.Debug.activate_debug (); - Logs.set_level (Some Logs.Warning) + Cohttp_lwt_unix.Debug.activate_debug (); + Logs.set_level (Some Logs.Warning) ]} @raise {!Connection.Retry} diff --git a/cohttp-lwt/src/server.ml b/cohttp-lwt/src/server.ml index 397b80e..8b89c5b 100644 --- a/cohttp-lwt/src/server.ml +++ b/cohttp-lwt/src/server.ml @@ -1,6 +1,6 @@ open Lwt.Infix module Header = Cohttp.Header -module Connection = Cohttp.Connection [@@warning "-3"] +module Connection = Cohttp.Connection module Make (IO : S.IO) = struct module IO = IO diff --git a/cohttp-mirage.opam b/cohttp-mirage.opam index 1130090..7858133 100644 --- a/cohttp-mirage.opam +++ b/cohttp-mirage.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP implementation for the MirageOS unikernel" @@ -34,14 +34,14 @@ depends: [ "mirage-channel" {>= "4.0.0"} "conduit" {>= "8.0.0"} "conduit-mirage" {>= "8.0.0"} - "mirage-kv" {>= "3.0.0"} + "mirage-kv" {>= "6.0.1"} "lwt" {>= "2.4.3"} "cohttp-lwt" {= version} "cstruct" {>= "6.0.0"} "fmt" {>= "0.8.7"} - "astring" "magic-mime" "ppx_sexp_conv" {>= "v0.13.0"} + "alcotest" {with-test & >= "1.7.0"} "cohttp" {= version} "odoc" {with-doc} ] diff --git a/cohttp-mirage/examples/dune b/cohttp-mirage/examples/dune new file mode 100644 index 0000000..e60f3eb --- /dev/null +++ b/cohttp-mirage/examples/dune @@ -0,0 +1,11 @@ +(executable + (name static_server) + (modules static_server) + (libraries + cohttp-mirage + cohttp-lwt-unix + mirage-kv + optint + lwt.unix + logs.fmt + fmt.tty)) diff --git a/cohttp-mirage/examples/static_server.ml b/cohttp-mirage/examples/static_server.ml new file mode 100644 index 0000000..f97655f --- /dev/null +++ b/cohttp-mirage/examples/static_server.ml @@ -0,0 +1,198 @@ +open Lwt.Infix + +module Dir : sig + include Mirage_kv.RO + + val connect : string -> t +end = struct + type t = { root : string } + type key = Mirage_kv.Key.t + type error = Mirage_kv.error + + let pp_error = Mirage_kv.pp_error + let connect root = { root } + let disconnect _ = Lwt.return_unit + + let path t key = + let segment s = + match s with + | "" | "." | ".." -> None + | s when String.exists (function '/' | '\000' -> true | _ -> false) s -> + None + | s -> Some s + in + let rec go acc = function + | [] -> Some acc + | s :: rest -> ( + match segment s with + | None -> None + | Some s -> go (Filename.concat acc s) rest) + in + go t.root (Mirage_kv.Key.segments key) + + let stat t key = + match path t key with + | None -> Lwt.return None + | Some path -> + Lwt.catch + (fun () -> Lwt_unix.stat path >|= fun stat -> Some (path, stat)) + (function + | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> + Lwt.return None + | e -> Lwt.reraise e) + + let get t key = + stat t key >>= function + | Some (path, { Unix.st_kind = Unix.S_REG; _ }) -> + Lwt_io.with_file ~mode:Lwt_io.Input path Lwt_io.read >|= Result.ok + | Some _ -> Lwt.return (Error (`Value_expected key)) + | None -> Lwt.return (Error (`Not_found key)) + + let exists t key = + stat t key >|= function + | Some (_, { Unix.st_kind = Unix.S_REG; _ }) -> Ok (Some `Value) + | Some (_, { Unix.st_kind = Unix.S_DIR; _ }) -> Ok (Some `Dictionary) + | Some _ | None -> Ok None + + let size t key = + stat t key >|= function + | Some (_, { Unix.st_size = size; _ }) -> Ok (Optint.Int63.of_int size) + | None -> Error (`Not_found key) + + let list t key = + match path t key with + | None -> Lwt.return (Error (`Not_found key)) + | Some dir -> + Lwt.catch + (fun () -> + Lwt_unix.files_of_directory dir + |> Lwt_stream.to_list + >>= Lwt_list.filter_map_s (fun name -> + if name = "." || name = ".." then Lwt.return_none + else + Lwt_unix.stat (Filename.concat dir name) + >|= fun { Unix.st_kind; _ } -> + match st_kind with + | Unix.S_REG -> Some (Mirage_kv.Key.add key name, `Value) + | Unix.S_DIR -> Some (Mirage_kv.Key.add key name, `Dictionary) + | _ -> None) + >|= Result.ok) + (function + | Unix.Unix_error ((Unix.ENOENT | Unix.ENOTDIR), _, _) -> + Lwt.return (Error (`Not_found key)) + | e -> Lwt.reraise e) + + let get_partial _ key ~offset:_ ~length:_ = + Lwt.return (Error (`Not_found key)) + + let last_modified _ key = Lwt.return (Error (`Not_found key)) + let digest _ key = Lwt.return (Error (`Not_found key)) +end + +let html_escape s = + let b = Buffer.create (String.length s) in + String.iter + (function + | '&' -> Buffer.add_string b "&" + | '<' -> Buffer.add_string b "<" + | '>' -> Buffer.add_string b ">" + | '"' -> Buffer.add_string b """ + | '\'' -> Buffer.add_string b "'" + | c -> Buffer.add_char b c) + s; + Buffer.contents b + +let html_of_listing dir entries = + let segments = Mirage_kv.Key.segments dir in + let link segments text = + let href = + segments + |> List.map (Uri.pct_encode ~component:`Path) + |> String.concat "/" + |> html_escape + in + Printf.sprintf {|
  • %s
    • |} href (html_escape text) + in + let parent = + match List.rev segments with + | [] -> [] + | _ :: up -> [ link (List.rev up) "../" ] + in + let entry (key, kind) = + let name = Mirage_kv.Key.basename key in + let text = match kind with `Dictionary -> name ^ "/" | `Value -> name in + (name, link (segments @ [ name ]) text) + in + let entries = + List.map entry entries + |> List.sort (fun (a, _) (b, _) -> String.compare a b) + |> List.map snd + in + let title = "Index of " ^ html_escape (Mirage_kv.Key.to_string dir) in + String.concat "\n" + ([ + ""; + ""; + "" ^ title ^ ""; + ""; + "

    " ^ title ^ "

    "; + ""; ""; ""; "" ]) + +module Generated_index (KV : Mirage_kv.RO) : Mirage_kv.RO with type t = KV.t = +struct + include KV + + let index = "index.html" + + let generates t key = + if Mirage_kv.Key.basename key <> index then Lwt.return_false + else + KV.exists t (Mirage_kv.Key.parent key) >|= function + | Ok (Some `Dictionary) -> true + | Ok (Some `Value | None) | Error _ -> false + + let get t key = + KV.get t key >>= function + | Ok _ as ok -> Lwt.return ok + | Error _ as error -> ( + generates t key >>= function + | false -> Lwt.return error + | true -> ( + let dir = Mirage_kv.Key.parent key in + KV.list t dir >|= function + | Ok entries -> Ok (html_of_listing dir entries) + | Error _ -> error)) + + let exists t key = + KV.exists t key >>= function + | Ok None -> ( + generates t key >|= function + | true -> Ok (Some `Value) + | false -> Ok None) + | r -> Lwt.return r +end + +module Store = Generated_index (Dir) +module Server = Cohttp_lwt_unix.Server +module Static = Cohttp_mirage.Static.HTTP (Store) (Server) + +let request_fn uri headers = + Cohttp.Header.add headers "x-served-by" + (Printf.sprintf "cohttp-mirage static (%s)" (Uri.path uri)) + +let () = + let docroot = if Array.length Sys.argv > 1 then Sys.argv.(1) else "htdocs" in + let port = + if Array.length Sys.argv > 2 then int_of_string Sys.argv.(2) else 8080 + in + Fmt_tty.setup_std_outputs (); + Logs.set_level (Some Logs.Info); + Logs.set_reporter (Logs_fmt.reporter ()); + Logs.info (fun f -> f "serving %s on http://0.0.0.0:%d/" docroot port); + Lwt_main.run + (Static.start ~http_port:port ~request_fn (Dir.connect docroot) + (fun (`TCP port) spec -> Server.create ~mode:(`TCP (`Port port)) spec)) diff --git a/cohttp-mirage/src/client.ml b/cohttp-mirage/src/client.ml index 5644293..0cd077c 100644 --- a/cohttp-mirage/src/client.ml +++ b/cohttp-mirage/src/client.ml @@ -14,7 +14,7 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * - * cohttp v6.2.2 + * cohttp v6.3.0 *) module Make (R : Resolver_mirage.S) (S : Conduit_mirage.S) = struct diff --git a/cohttp-mirage/src/dune b/cohttp-mirage/src/dune index a318811..7e2d867 100644 --- a/cohttp-mirage/src/dune +++ b/cohttp-mirage/src/dune @@ -10,5 +10,4 @@ mirage-channel mirage-kv mirage-flow - magic-mime - astring)) + magic-mime)) diff --git a/cohttp-mirage/src/io.ml b/cohttp-mirage/src/io.ml index f5124f1..8267c34 100644 --- a/cohttp-mirage/src/io.ml +++ b/cohttp-mirage/src/io.ml @@ -14,7 +14,7 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * - * cohttp v6.2.2 + * cohttp v6.3.0 *) open Lwt.Infix diff --git a/cohttp-mirage/src/io.mli b/cohttp-mirage/src/io.mli index b397149..6689947 100644 --- a/cohttp-mirage/src/io.mli +++ b/cohttp-mirage/src/io.mli @@ -14,7 +14,7 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * - * cohttp v6.2.2 + * cohttp v6.3.0 *) (** Cohttp IO implementation using Mirage channels. *) diff --git a/cohttp-mirage/src/static.ml b/cohttp-mirage/src/static.ml index 77a4f5c..c3b33af 100644 --- a/cohttp-mirage/src/static.ml +++ b/cohttp-mirage/src/static.ml @@ -14,15 +14,14 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * - * cohttp v6.2.2 + * cohttp v6.3.0 *) module Key = Mirage_kv.Key -module Connection = Cohttp.Connection [@@warning "-3"] +module Connection = Cohttp.Connection module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct open Lwt.Infix - open Astring let failf fmt = Fmt.failwith fmt @@ -38,34 +37,27 @@ module HTTP (FS : Mirage_kv.RO) (S : Cohttp_lwt.S.Server) = struct | Error e -> Fmt.failwith "exists %a" FS.pp_error e let dispatcher request_fn = - let rec fn fs uri = - match Uri.path uri with - | ("" | "/") as path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path when String.is_suffix ~affix:"/" path -> - Logs.info (fun f -> f "request for '%s'" path); - fn fs (Uri.with_path uri "index.html") - | path -> - Logs.info (fun f -> f "request for '%s'" path); - Lwt.catch - (fun () -> - read_fs fs path >>= fun body -> - let mime_type = Magic_mime.lookup path in - let headers = Cohttp.Header.init_with "content-type" mime_type in - let headers = - match request_fn with - | None -> headers - | Some fn -> fn uri headers - in - S.respond_string ~status:`OK ~body ~headers ()) - (fun _exn -> - let with_index = Fmt.str "%s/index.html" path in - exists fs with_index >>= function - | true -> fn fs (Uri.with_path uri with_index) - | false -> S.respond_not_found ()) + let respond uri path body = + let mime_type = Magic_mime.lookup path in + let headers = Cohttp.Header.init_with "content-type" mime_type in + let headers = + match request_fn with None -> headers | Some fn -> fn uri headers + in + S.respond_string ~status:`OK ~body ~headers () in - fn + fun fs uri -> + let path = + match Cohttp.Path.normalise uri with "" -> "index.html" | path -> path + in + Logs.info (fun f -> f "request for %S" path); + Lwt.try_bind + (fun () -> read_fs fs path) + (respond uri path) + (fun _exn -> + let with_index = path ^ "/index.html" in + exists fs with_index >>= function + | true -> read_fs fs with_index >>= respond uri with_index + | false -> S.respond_not_found ()) let start ~http_port ?request_fn fs http = let callback (_, cid) request _body = diff --git a/cohttp-mirage/src/static.mli b/cohttp-mirage/src/static.mli index 4d2d2ce..1ff2752 100644 --- a/cohttp-mirage/src/static.mli +++ b/cohttp-mirage/src/static.mli @@ -14,7 +14,7 @@ * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. * - * cohttp v6.2.2 + * cohttp v6.3.0 *) (** Serve static HTTP sites from a Mirage key-value store. *) diff --git a/cohttp-mirage/test/dune b/cohttp-mirage/test/dune new file mode 100644 index 0000000..b3be3bf --- /dev/null +++ b/cohttp-mirage/test/dune @@ -0,0 +1,10 @@ +(executable + (name test_static) + (modules test_static) + (libraries cohttp-mirage cohttp-lwt cohttp http lwt mirage-kv uri alcotest)) + +(rule + (alias runtest) + (package cohttp-mirage) + (action + (run ./test_static.exe))) diff --git a/cohttp-mirage/test/test_static.ml b/cohttp-mirage/test/test_static.ml new file mode 100644 index 0000000..3df207b --- /dev/null +++ b/cohttp-mirage/test/test_static.ml @@ -0,0 +1,214 @@ +(* Tests for [Cohttp_mirage.Static.HTTP]. *) + +let run p = + match Lwt.state p with + | Lwt.Return v -> v + | Lwt.Fail e -> raise e + | Lwt.Sleep -> Alcotest.fail "promise did not resolve" + +(* An in-memory [Mirage_kv.RO] over a list of (key, contents) pairs. *) +module Mock_fs : sig + include Mirage_kv.RO + + val create : (string * string) list -> t +end = struct + type t = (string * string) list + type key = Mirage_kv.Key.t + type error = Mirage_kv.error + + let pp_error = Mirage_kv.pp_error + let create entries = entries + let disconnect _ = Lwt.return_unit + let path key = String.concat "/" (Mirage_kv.Key.segments key) + + let is_dictionary t path = + let prefix = path ^ "/" in + List.exists (fun (k, _) -> String.starts_with ~prefix k) t + + let get t key = + let path = path key in + match List.assoc_opt path t with + | Some contents -> Lwt.return (Ok contents) + | None when is_dictionary t path -> Lwt.return (Error (`Value_expected key)) + | None -> Lwt.return (Error (`Not_found key)) + + let exists t key = + let path = path key in + if List.mem_assoc path t then Lwt.return (Ok (Some `Value)) + else if is_dictionary t path then Lwt.return (Ok (Some `Dictionary)) + else Lwt.return (Ok None) + + let unsupported _ = Alcotest.fail "unexpected key-value store operation" + let get_partial _ _ ~offset:_ ~length:_ = unsupported () + let list _ _ = unsupported () + let last_modified _ _ = unsupported () + let digest _ _ = unsupported () + let size _ _ = unsupported () +end + +module Mock_server : sig + include Cohttp_lwt.S.Server + + val serve : t -> string -> (Http.Response.t * Cohttp_lwt.Body.t) Lwt.t +end = struct + module IO = struct + type 'a t = 'a Lwt.t + + let ( >>= ) = Lwt.bind + let return = Lwt.return + + type ic = unit + type oc = unit + type conn = unit + type error = | + + let refill () = Lwt.return `Eof + let with_input_buffer () ~f = fst (f "" ~pos:0 ~len:0) + let read_line () = Lwt.return None + let read () _ = Lwt.return "" + let write () _ = Lwt.return_unit + let flush () = Lwt.return_unit + let catch f = Lwt.map Result.ok (f ()) + let pp_error _ = function (_ : error) -> . + end + + type body = Cohttp_lwt.Body.t + type conn = IO.conn * Cohttp.Connection.t [@@warning "-3"] + type response = Http.Response.t * body + + type response_action = + [ `Expert of Http.Response.t * (IO.ic -> IO.oc -> unit IO.t) + | `Response of response ] + + type t = { handler : conn -> Http.Request.t -> body -> response Lwt.t } + + let make ?conn_closed:_ ~callback () = { handler = callback } + let unsupported _ = Alcotest.fail "unexpected server operation" + let make_response_action ?conn_closed:_ ~callback:_ () = unsupported () + let make_expert ?conn_closed:_ ~callback:_ () = unsupported () + let callback _ _ _ _ = unsupported () + + let resolve_local_file ~docroot ~uri = + Cohttp.Path.resolve_local_file ~docroot ~uri + + let respond ?(headers = Http.Header.init ()) ~status ~body () = + Lwt.return (Http.Response.make ~status ~headers (), body) + + let respond_string ?headers ~status ~body () = + respond ?headers ~status ~body:(`String body) () + + let respond_error ?headers ?(status = `Internal_server_error) ~body () = + respond_string ?headers ~status ~body () + + let respond_redirect ?(headers = Http.Header.init ()) ~uri () = + let headers = Http.Header.add headers "location" (Uri.to_string uri) in + respond_string ~headers ~status:`Found ~body:"" () + + let respond_need_auth ?(headers = Http.Header.init ()) ~auth () = + let headers = Cohttp.Header.add_authorization_req headers auth in + respond_string ~headers ~status:`Unauthorized ~body:"" () + + let respond_not_found ?uri:_ () = + respond_string ~status:`Not_found ~body:"Not found" () + + let serve t target = + let request = Http.Request.make ~meth:`GET target in + t.handler ((), (Cohttp.Connection.create () [@warning "-3"])) request `Empty +end + +module Static = Cohttp_mirage.Static.HTTP (Mock_fs) (Mock_server) + +let store = + Mock_fs.create + [ + ("index.html", "root index"); + ("foo/index.html", "foo index"); + ("foo/bar/index.html", "foo/bar index"); + ("style.css", "css body"); + ("my file.txt", "spaced"); + ] + +let request ?request_fn target = + let t = Static.start ~http_port:8080 ?request_fn store (fun _ t -> t) in + let response, body = run (Mock_server.serve t target) in + (response, run (Cohttp_lwt.Body.to_string body)) + +let check_served name ~target ~expected = + let response, body = request target in + Alcotest.(check int) + (name ^ ": status") 200 + (Http.Status.to_int (Http.Response.status response)); + Alcotest.(check string) (name ^ ": body") expected body + +let check_not_found name ~target = + let response, _ = request target in + Alcotest.(check int) + (name ^ ": status") 404 + (Http.Status.to_int (Http.Response.status response)) + +let test_index_pages () = + check_served "root" ~target:"/" ~expected:"root index"; + check_served "directory" ~target:"/foo" ~expected:"foo index"; + check_served "directory trailing slash" ~target:"/foo/" ~expected:"foo index"; + check_served "nested directory" ~target:"/foo/bar" ~expected:"foo/bar index"; + check_served "nested directory trailing slash" ~target:"/foo/bar/" + ~expected:"foo/bar index"; + check_served "empty segments collapsed" ~target:"/foo//bar/" + ~expected:"foo/bar index" + +let test_files () = + check_served "file" ~target:"/style.css" ~expected:"css body"; + check_not_found "missing file" ~target:"/nope.css"; + check_not_found "missing directory" ~target:"/nope/" + +let test_content_type () = + let response, _ = request "/style.css" in + Alcotest.(check (option string)) + "css content-type" (Some "text/css") + (Http.Header.get (Http.Response.headers response) "content-type"); + let response, _ = request "/foo/" in + Alcotest.(check (option string)) + "index content-type is that of the page served, not the directory" + (Some "text/html") + (Http.Header.get (Http.Response.headers response) "content-type") + +let test_traversal_clamped () = + check_served "dot-dot" ~target:"/foo/../style.css" ~expected:"css body"; + check_served "dot-dot above root" ~target:"/../../style.css" + ~expected:"css body"; + check_served "encoded slash" ~target:"/..%2f..%2fstyle.css" + ~expected:"css body"; + check_served "fully encoded" ~target:"/%2e%2e%2f%2e%2e%2fstyle.css" + ~expected:"css body"; + check_served "encoded slash into directory index" ~target:"/foo%2fbar%2f" + ~expected:"foo/bar index" + +(* Percent-decoding should happens exactly once. *) +let test_single_decode () = + check_served "encoded space" ~target:"/my%20file.txt" ~expected:"spaced"; + check_not_found "double encoded slash" ~target:"/..%252f..%252fstyle.css"; + check_not_found "double encoded, fully" ~target:"/%252e%252e%252fstyle.css" + +let test_request_fn () = + let request_fn uri headers = + Http.Header.add headers "x-request-uri" (Uri.path uri) + in + let response, body = request ~request_fn "/foo/" in + Alcotest.(check string) "index still served" "foo index" body; + Alcotest.(check (option string)) + "request_fn sees the request URI" (Some "/foo/") + (Http.Header.get (Http.Response.headers response) "x-request-uri") + +let () = + Alcotest.run "cohttp-mirage static" + [ + ( "paths", + [ + ("index pages", `Quick, test_index_pages); + ("files", `Quick, test_files); + ("content types", `Quick, test_content_type); + ("traversal clamped to root", `Quick, test_traversal_clamped); + ("single percent-decode", `Quick, test_single_decode); + ("request_fn", `Quick, test_request_fn); + ] ); + ] diff --git a/cohttp-server-lwt-unix.opam b/cohttp-server-lwt-unix.opam index 2e1f87f..c3afe96 100644 --- a/cohttp-server-lwt-unix.opam +++ b/cohttp-server-lwt-unix.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Lightweight Cohttp + Lwt based HTTP server" diff --git a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml index 054ac93..1d60f23 100644 --- a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml +++ b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.ml @@ -290,10 +290,10 @@ module Context = struct let* () = Http.Header.to_list headers |> Lwt_list.iter_s (fun (k, v) -> - let* () = Lwt_io.write t.oc k in - let* () = Lwt_io.write t.oc ": " in - let* () = Lwt_io.write t.oc v in - Lwt_io.write t.oc "\r\n") + let* () = Lwt_io.write t.oc k in + let* () = Lwt_io.write t.oc ": " in + let* () = Lwt_io.write t.oc v in + Lwt_io.write t.oc "\r\n") in let* () = Lwt_io.write t.oc "\r\n" in Body.write body t.oc diff --git a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli index 4eb6809..64a987e 100644 --- a/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli +++ b/cohttp-server-lwt-unix/src/cohttp_server_lwt_unix.mli @@ -12,28 +12,28 @@ An example server: {[ - open Lwt.Syntax - - let server_callback ctx = - Lwt.join - [ - Cohttp_server_lwt_unix.ontext.discard_body ctx; - Cohttp_server_lwt_unix.ontext.respond ctx (Http.Response.make ()) - (Cohttp_server_lwt_unix.Body.string "hello world"); - ] - - let main () = - let* _server = - let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in - let server = Cohttp_server_lwt_unix.create server_callback in - Lwt_io.establish_server_with_client_address ~backlog:10_000 - listen_address (fun _addr ch -> - Cohttp_server_lwt_unix.handle_connection server ch) - in - let forever, _ = Lwt.wait () in - forever - - let () = ignore (Lwt_main.run (main ())) + open Lwt.Syntax + + let server_callback ctx = + Lwt.join + [ + Cohttp_server_lwt_unix.ontext.discard_body ctx; + Cohttp_server_lwt_unix.ontext.respond ctx (Http.Response.make ()) + (Cohttp_server_lwt_unix.Body.string "hello world"); + ] + + let main () = + let* _server = + let listen_address = Unix.(ADDR_INET (inet_addr_loopback, 8080)) in + let server = Cohttp_server_lwt_unix.create server_callback in + Lwt_io.establish_server_with_client_address ~backlog:10_000 + listen_address (fun _addr ch -> + Cohttp_server_lwt_unix.handle_connection server ch) + in + let forever, _ = Lwt.wait () in + forever + + let () = ignore (Lwt_main.run (main ())) ]} *) module Body : sig diff --git a/cohttp-top.opam b/cohttp-top.opam index e27d0ac..f363242 100644 --- a/cohttp-top.opam +++ b/cohttp-top.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "CoHTTP toplevel pretty printers for HTTP types" diff --git a/cohttp.opam b/cohttp.opam index f11d47d..77102bd 100644 --- a/cohttp.opam +++ b/cohttp.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "An OCaml library for HTTP clients and servers" diff --git a/cohttp/src/cohttp.ml b/cohttp/src/cohttp.ml index 76f7486..f38a742 100644 --- a/cohttp/src/cohttp.ml +++ b/cohttp/src/cohttp.ml @@ -2,7 +2,7 @@ module Accept = Accept module Auth = Auth module Body = Body module Conf = Conf -module Connection = Connection [@@deprecated "Connection.t values are useless."] +module Connection = Connection module Code = Code module Cookie = Cookie module Header = Header diff --git a/cohttp/src/path.ml b/cohttp/src/path.ml index cd614ce..eeb21d2 100644 --- a/cohttp/src/path.ml +++ b/cohttp/src/path.ml @@ -1,7 +1,12 @@ -let resolve_local_file ~docroot ~uri = - let path = Uri.(pct_decode (path (resolve "http" (of_string "/") uri))) in - let rel_path = - if String.length path > 0 then String.sub path 1 (String.length path - 1) - else "" +let remove_dot_segments path = + let rec go acc = function + | [] -> List.rev acc + | ("" | ".") :: rest -> go acc rest + | ".." :: rest -> ( + match acc with [] -> go [] rest | _ :: tl -> go tl rest) + | seg :: rest -> go (seg :: acc) rest in - Filename.concat docroot rel_path + path |> String.split_on_char '/' |> go [] |> String.concat "/" + +let normalise uri = uri |> Uri.path |> Uri.pct_decode |> remove_dot_segments +let resolve_local_file ~docroot ~uri = Filename.concat docroot (normalise uri) diff --git a/cohttp/src/path.mli b/cohttp/src/path.mli index 6019015..9a00881 100644 --- a/cohttp/src/path.mli +++ b/cohttp/src/path.mli @@ -1,6 +1,15 @@ val resolve_local_file : docroot:string -> uri:Uri.t -> string (** Resolve the given URI to a local file in the given docroot. - This decodes and normalises the Uri. It strips out .. characters so that the - request will not escape the docroot. The returned filepath is fully - qualified iff the given docroot is fully qualified. *) + This is [Filename.concat docroot (normalise uri)]. It decodes + percent-encoding once and removes [..] segments so that the request cannot + escape the docroot. The returned filepath is fully qualified iff the given + docroot is fully qualified. *) + +val normalise : Uri.t -> string +(** [normalise uri] returns the path of [uri] with percent-encoding decoded + exactly once and [.]/[..] segments resolved, as a relative path that can + never ascend above its root. + + Use this to derive a lookup key from a request URI, for example a filesystem + path or a key-value store key. *) diff --git a/cohttp/src/proxy.ml b/cohttp/src/proxy.ml index 5f5251b..6aa2a19 100644 --- a/cohttp/src/proxy.ml +++ b/cohttp/src/proxy.ml @@ -32,15 +32,14 @@ module Forward = struct no_proxy |> String.split_on_char ',' |> List.filter_map (fun pattern -> - if pattern = "" then None else Some (String.trim pattern)) + if pattern = "" then None else Some (String.trim pattern)) |> List.map (fun pattern -> - match Ipaddr.of_string pattern with - | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr) - | Error _ -> ( - match Ipaddr.Prefix.of_string pattern with - | Ok prefix -> Ipaddr_prefix prefix - | Error _ -> Name (trim_dots ~first_leading:true pattern) - )) + match Ipaddr.of_string pattern with + | Ok addr -> Ipaddr_prefix (Ipaddr.Prefix.of_addr addr) + | Error _ -> ( + match Ipaddr.Prefix.of_string pattern with + | Ok prefix -> Ipaddr_prefix prefix + | Error _ -> Name (trim_dots ~first_leading:true pattern))) in Patterns patterns diff --git a/cohttp/src/response.ml b/cohttp/src/response.ml index bfc532d..a97b238 100644 --- a/cohttp/src/response.ml +++ b/cohttp/src/response.ml @@ -40,23 +40,21 @@ let status t = t.status let make ?(version = `HTTP_1_1) ?(status = `OK) ?(encoding = Transfer.Unknown) ?(headers = Header.init ()) () = let headers = - match encoding with - | Unknown -> ( - match Header.get_transfer_encoding headers with - | Unknown -> Header.add_transfer_encoding headers Chunked - | _ -> headers) - | _ -> Header.add_transfer_encoding headers encoding + if not (Http.Status.body_allowed status) then headers + else + match encoding with + | Unknown -> ( + match Header.get_transfer_encoding headers with + | Unknown -> Header.add_transfer_encoding headers Chunked + | _ -> headers) + | _ -> Header.add_transfer_encoding headers encoding in { headers; version; status } let pp_hum ppf r = Format.fprintf ppf "%s" (r |> sexp_of_t |> Sexplib0.Sexp.to_string_hum) -let allowed_body response = - (* rfc7230#section-5.7.1 *) - match status response with - | #Code.informational_status | `No_content | `Not_modified -> false - | #Code.status_code -> true +let allowed_body response = Http.Status.body_allowed (status response) let has_body response = if allowed_body response then Transfer.has_body (encoding response) else `No diff --git a/cohttp/src/server.ml b/cohttp/src/server.ml index 0c26753..c83bf70 100644 --- a/cohttp/src/server.ml +++ b/cohttp/src/server.ml @@ -2,7 +2,7 @@ module type S = sig module IO : S.IO type body - type conn = IO.conn * Connection.t [@@warning "-3"] + type conn = IO.conn * Connection.t type response type response_action = diff --git a/cohttp/test/dune b/cohttp/test/dune index 090b786..ca47fa8 100644 --- a/cohttp/test/dune +++ b/cohttp/test/dune @@ -69,3 +69,15 @@ (package cohttp) (action (run ./test_proxy.exe))) + +(executable + (name test_response) + (modules test_response) + (forbidden_libraries base) + (libraries cohttp alcotest)) + +(rule + (alias runtest) + (package cohttp) + (action + (run ./test_response.exe))) diff --git a/cohttp/test/test_path.ml b/cohttp/test/test_path.ml index 1feabe0..43a4980 100644 --- a/cohttp/test/test_path.ml +++ b/cohttp/test/test_path.ml @@ -70,6 +70,50 @@ let test_resolve_local_file () = ("cwd-docroot cwd", ".", "./buzz", "./buzz"); ("cwd-docroot blank-path", ".", "https://example.com", "./"); ("cwd-docroot blank-uri", ".", "", "./"); + ( "percent-encoded slash grandparent blocked", + "/foo/bar/baz", + "..%2f..%2fbuzz", + "/foo/bar/baz/buzz" ); + ( "fully percent-encoded grandparent blocked", + "/foo/bar/baz", + "%2e%2e%2f%2e%2e%2fbuzz", + "/foo/bar/baz/buzz" ); + ( "double percent-encoded grandparent blocked", + "/foo/bar/baz", + "..%252f..%252fbuzz", + "/foo/bar/baz/..%2f..%2fbuzz" ); + ( "double fully percent-encoded grandparent blocked", + "/foo/bar/baz", + "%252e%252e%252f%252e%252e%252fbuzz", + "/foo/bar/baz/%2e%2e%2f%2e%2e%2fbuzz" ); + ( "triply percent-encoded grandparent blocked", + "/foo/bar/baz", + "..%25252f..%25252fbuzz", + "/foo/bar/baz/..%252f..%252fbuzz" ); + ( "encoded space preserved", + "/foo/bar/baz", + "/my%20file.txt", + "/foo/bar/baz/my file.txt" ); + ( "encoded utf8 preserved", + "/foo/bar/baz", + "/caf%C3%A9.txt", + "/foo/bar/baz/caf\xc3\xa9.txt" ); + ( "encoded NUL preserved", + "/foo/bar/baz", + "/secret%00.txt", + "/foo/bar/baz/secret\x00.txt" ); + ( "encoded newline preserved", + "/foo/bar/baz", + "/a%0ab.txt", + "/foo/bar/baz/a\nb.txt" ); + ( "encoded DEL preserved", + "/foo/bar/baz", + "/a%7fb.txt", + "/foo/bar/baz/a\x7fb.txt" ); + ( "encoded control does not collapse onto plain name", + "/foo/bar/baz", + "/sol%001.html", + "/foo/bar/baz/sol\x001.html" ); ] in List.iter @@ -79,10 +123,49 @@ let test_resolve_local_file () = (Cohttp.Path.resolve_local_file ~docroot ~uri:(Uri.of_string uri))) tests +let test_normalise () = + let tests = + [ + ("relative simple", "/foo/bar", "foo/bar"); + ("relative dot", "/foo/./bar", "foo/bar"); + ("relative grandparent blocked", "/../../etc/passwd", "etc/passwd"); + ("encoded slash traversal blocked", "/..%2f..%2fetc/passwd", "etc/passwd"); + ( "absolute-form grandparent blocked", + "http://host/../../etc/passwd", + "etc/passwd" ); + ( "absolute-form deep grandparent blocked", + "https://example.com/a/../../../../etc/shadow", + "etc/shadow" ); + ("root path empty", "/", ""); + ("empty path", "", ""); + ("trailing slash dropped", "/foo/bar/", "foo/bar"); + ("encoded trailing slash dropped", "/foo/bar%2f", "foo/bar"); + ("empty segments collapsed", "/foo//bar", "foo/bar"); + ("encoded control preserved", "/sol%001.html", "sol\x001.html"); + ("plain slash separator", "/private/secret.txt", "private/secret.txt"); + ( "backslash preserved, distinct from slash", + "/private%5csecret.txt", + "private\\secret.txt" ); + ( "encoded backslash traversal preserved verbatim", + "/..%5c..%5cwindows", + "..\\..\\windows" ); + ] + in + List.iter + (fun (name, uri, expected) -> + Alcotest.(check string) + name expected + (Cohttp.Path.normalise (Uri.of_string uri))) + tests + let () = Printexc.record_backtrace true let () = Alcotest.run "test_path" [ - ("Path", [ ("Check resolve_local_file", `Quick, test_resolve_local_file) ]); + ( "Path", + [ + ("Check resolve_local_file", `Quick, test_resolve_local_file); + ("Check normalise", `Quick, test_normalise); + ] ); ] diff --git a/cohttp/test/test_response.ml b/cohttp/test/test_response.ml new file mode 100644 index 0000000..d15f7ab --- /dev/null +++ b/cohttp/test/test_response.ml @@ -0,0 +1,148 @@ +open Cohttp +module String_io = Cohttp.Private.String_io +module Response_io = Response.Private.Make (String_io.M) + +let t_encoding = + Alcotest.testable + (fun fmt e -> Format.pp_print_string fmt (Transfer.string_of_encoding e)) + ( = ) + +let check_encoding name expected response = + Alcotest.check t_encoding name expected (Response.encoding response) + +let check_no_framing_headers name response = + let headers = Response.headers response in + Alcotest.(check (option string)) + (name ^ ": no transfer-encoding header") + None + (Header.get headers "transfer-encoding"); + Alcotest.(check (option string)) + (name ^ ": no content-length header") + None + (Header.get headers "content-length") + +let bodyless_statuses = + [ + `Continue; + `Switching_protocols; + `Processing; + `Checkpoint; + `No_content; + `Not_modified; + `Code 199; + ] + +let iter_bodyless f = + List.iter + (fun status -> f (Code.string_of_status status) status) + bodyless_statuses + +let default_encoding_is_chunked () = + check_encoding "unspecified encoding defaults to chunked" Transfer.Chunked + (Response.make ()) + +let explicit_encoding_is_used () = + check_encoding "explicit encoding is used" (Transfer.Fixed 5L) + (Response.make ~status:`OK ~encoding:(Transfer.Fixed 5L) ()) + +let encoding_from_headers () = + check_encoding "encoding taken from supplied headers" (Transfer.Fixed 42L) + (Response.make ~status:`OK + ~headers:(Header.of_list [ ("content-length", "42") ]) + ()) + +let bodyless_has_no_encoding () = + iter_bodyless (fun name status -> + let r = Response.make ~status () in + check_encoding (name ^ " is not chunked by default") Transfer.Unknown r; + check_no_framing_headers name r) + +let bodyless_ignores_explicit_encoding () = + iter_bodyless (fun name status -> + let chunked = Response.make ~status ~encoding:Transfer.Chunked () in + check_encoding + (name ^ " drops an explicit chunked encoding") + Transfer.Unknown chunked; + check_no_framing_headers (name ^ " (chunked)") chunked; + let fixed = Response.make ~status ~encoding:(Transfer.Fixed 0L) () in + check_encoding + (name ^ " drops an explicit fixed encoding") + Transfer.Unknown fixed; + check_no_framing_headers (name ^ " (fixed)") fixed) + +let t_has_body = + Alcotest.testable + (fun fmt -> function + | `No -> Format.pp_print_string fmt "`No" + | `Unknown -> Format.pp_print_string fmt "`Unknown" + | `Yes -> Format.pp_print_string fmt "`Yes") + ( = ) + +let bodyless_has_no_body () = + iter_bodyless (fun name status -> + Alcotest.check t_has_body (name ^ " has no body") `No + (Response.has_body (Response.make ~status ()))) + +let write_response r = + let buf = Buffer.create 128 in + Response_io.write ~flush:false (fun _ -> ()) r buf; + Buffer.contents buf + +let write_chunked_response () = + Alcotest.(check string) + "a 200 response is framed as chunked" + "HTTP/1.1 200 OK\r\ntransfer-encoding: chunked\r\n\r\n0\r\n\r\n" + (write_response (Response.make ())) + +let write_switching_protocols () = + let r = + Response.make ~status:`Switching_protocols + ~headers: + (Header.of_list [ ("upgrade", "websocket"); ("connection", "Upgrade") ]) + () + in + Alcotest.(check string) + "a 101 response is written without any framing" + "HTTP/1.1 101 Switching Protocols\r\n\ + upgrade: websocket\r\n\ + connection: Upgrade\r\n\ + \r\n" + (write_response r) + +let write_no_content () = + Alcotest.(check string) + "a 204 response is written without any framing" + "HTTP/1.1 204 No Content\r\n\r\n" + (write_response (Response.make ~status:`No_content ())) + +let write_not_modified () = + Alcotest.(check string) + "a 304 response is written without any framing" + "HTTP/1.1 304 Not Modified\r\n\r\n" + (write_response (Response.make ~status:`Not_modified ())) + +let () = + Alcotest.run "test_response" + [ + ( "Encoding", + [ + ("default is chunked", `Quick, default_encoding_is_chunked); + ("explicit encoding", `Quick, explicit_encoding_is_used); + ("from headers", `Quick, encoding_from_headers); + ] ); + ( "Bodyless statuses", + [ + ("no encoding by default", `Quick, bodyless_has_no_encoding); + ( "explicit encoding ignored", + `Quick, + bodyless_ignores_explicit_encoding ); + ("no body", `Quick, bodyless_has_no_body); + ] ); + ( "Serialization", + [ + ("chunked", `Quick, write_chunked_response); + ("101 Switching Protocols", `Quick, write_switching_protocols); + ("204 No Content", `Quick, write_no_content); + ("304 Not Modified", `Quick, write_not_modified); + ] ); + ] diff --git a/dune-project b/dune-project index 2d5e1d3..c30d008 100644 --- a/dune-project +++ b/dune-project @@ -1,7 +1,7 @@ (lang dune 3.8) (name cohttp) -(version v6.2.2) +(version v6.3.0) (license ISC) @@ -193,7 +193,7 @@ "An implementation of an HTTP client and server using the Async\nconcurrency library. See the `Cohttp_async` module for information\non how to use this. The package also installs `cohttp-curl-async`\nand a `cohttp-server-async` binaries for quick uses of a HTTP(S)\nclient and server respectively.\n") (depends (ocaml - (and (>= 4.14) (< 5.3.0))) + (>= 4.14)) (http (= :version)) (cohttp @@ -242,7 +242,7 @@ (conduit-mirage (>= 8.0.0)) (mirage-kv - (>= 3.0.0)) + (>= 6.0.1)) (lwt (>= 2.4.3)) (cohttp-lwt @@ -251,10 +251,13 @@ (>= 6.0.0)) (fmt (>= 0.8.7)) - astring magic-mime (ppx_sexp_conv (>= v0.13.0)) + (alcotest + (and + :with-test + (>= 1.7.0))) (cohttp (= :version)))) @@ -286,7 +289,7 @@ (depends (ocaml (>= 4.08)) - (ocurl (>= 0.9.2)) + (curl (>= 0.10.0)) (http (= :version)) stringext)) @@ -299,7 +302,7 @@ (depends (ocaml (>= 4.08)) - (ocurl (>= 0.9.2)) + (curl (>= 0.10.0)) (http (= :version)) (cohttp-curl @@ -338,7 +341,7 @@ (description "An HTTP client that relies on Curl + Async for the backend. Does not require\nconduit for SSL.") (depends - (ocurl (>= 0.9.2)) + (curl (>= 0.10.0)) (http (= :version)) stringext diff --git a/flake.nix b/flake.nix index 0dd9327..9b53d31 100644 --- a/flake.nix +++ b/flake.nix @@ -117,9 +117,10 @@ }; cohttp-mirage = pkg { pname = "cohttp-mirage"; + checkInputs = [ alcotest ]; propagatedBuildInputs = [ mirage-flow mirage-channel conduit conduit-mirage - mirage-kv lwt cohttp-lwt cstruct fmt astring magic-mime ppx_sexp_conv + mirage-kv lwt cohttp-lwt cstruct fmt magic-mime ppx_sexp_conv ]; }; cohttp-bench = pkg { diff --git a/http.opam b/http.opam index 7b13443..284106d 100644 --- a/http.opam +++ b/http.opam @@ -1,4 +1,4 @@ -version: "6.2.2" +version: "6.3.0" # This file is generated by dune, edit dune-project instead opam-version: "2.0" synopsis: "Type definitions of HTTP essentials" diff --git a/http/src/http.ml b/http/src/http.ml index b90e11b..5f8ff2d 100644 --- a/http/src/http.ml +++ b/http/src/http.ml @@ -204,10 +204,10 @@ module Header = struct let b = Buffer.create 128 in to_list h |> List.iter (fun (k, v) -> - Buffer.add_string b k; - Buffer.add_string b ": "; - Buffer.add_string b v; - Buffer.add_string b "\r\n"); + Buffer.add_string b k; + Buffer.add_string b ": "; + Buffer.add_string b v; + Buffer.add_string b "\r\n"); Buffer.add_string b "\r\n"; Buffer.contents b @@ -569,6 +569,10 @@ module Status = struct | `Network_connect_timeout_error -> 599 | `Code code -> code + (* Defined for status codes in RFC7230 *) + let body_allowed t = + match to_int t with 204 | 304 -> false | code -> code < 100 || code >= 200 + let reason_phrase_of_code : int -> string = function | 100 -> "Continue" | 101 -> "Switching Protocols" diff --git a/http/src/http.mli b/http/src/http.mli index 32713cf..4a3351c 100644 --- a/http/src/http.mli +++ b/http/src/http.mli @@ -153,6 +153,15 @@ module Status : sig val to_string : t -> string val to_int : t -> int val of_int : int -> t + + val body_allowed : t -> bool + (** [body_allowed status] returns whether a response with [status] allows a + payload body to be present per RFC7230. A [1xx], [204] or [304] response + is always terminated by the first empty line after the header fields, and + so carries neither a body nor any framing header. + + https://www.rfc-editor.org/rfc/rfc7230#section-3.3 *) + val reason_phrase_of_code : int -> string val pp : Format.formatter -> t -> unit end @@ -341,19 +350,19 @@ module Header : sig example below) are not affected by [clean_dup]. For example, {v - transfer-encoding: gzip - host: afirsthost.com - connection: keep-alive - host: anhost.com, anotherhost.com - transfer-encoding: chunked + transfer-encoding: gzip + host: afirsthost.com + connection: keep-alive + host: anhost.com, anotherhost.com + transfer-encoding: chunked v} becomes {v - transfer-encoding: gzip, chunked - connection: keep-alive - host: anhost.com, anotherhost.com + transfer-encoding: gzip, chunked + connection: keep-alive + host: anhost.com, anotherhost.com v} Finally, following diff --git a/http/test/test_request.ml b/http/test/test_request.ml index e380394..e85b125 100644 --- a/http/test/test_request.ml +++ b/http/test/test_request.ml @@ -6,7 +6,7 @@ let requires_content_length_tests = let valid_meth () = [ `POST; `PUT; `PATCH ] |> List.map (fun meth -> - Request.make ~meth "p" |> Request.requires_content_length) + Request.make ~meth "p" |> Request.requires_content_length) |> List.for_all Fun.id |> aeb "requires_content_length m = true, where m is `POST, `PUT or `PATCH" true @@ -14,7 +14,7 @@ let requires_content_length_tests = let invalid_meth () = [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ] |> List.map (fun meth -> - Request.make ~meth "p" |> Request.requires_content_length) + Request.make ~meth "p" |> Request.requires_content_length) |> List.for_all not |> aeb {| requires_content_length m = false, where m is `GET; `HEAD;`DELETE;`OPTIONS;`TRACE; `CONNECT;`Other "h" |} @@ -29,14 +29,14 @@ let content_length_tests = let some_x () = [ (`POST, "0"); (`PUT, "233"); (`PATCH, "012345") ] |> List.map (fun (meth, len) -> - match - Request.make ~meth - ~headers:(Header.of_list [ ("Content-Length", len) ]) - "p" - |> Request.content_length - with - | Some x -> int_of_string len = x - | None -> false) + match + Request.make ~meth + ~headers:(Header.of_list [ ("Content-Length", len) ]) + "p" + |> Request.content_length + with + | Some x -> int_of_string len = x + | None -> false) |> List.for_all Fun.id |> aeb "content_length t = Some x" true in @@ -44,14 +44,14 @@ let content_length_tests = let none () = [ (`POST, "-1"); (`PUT, "-233"); (`PATCH, "abc") ] |> List.map (fun (meth, len) -> - match - Request.make ~meth - ~headers:(Header.of_list [ ("Content-Length", len) ]) - "p" - |> Request.content_length - with - | Some _ -> false - | None -> true) + match + Request.make ~meth + ~headers:(Header.of_list [ ("Content-Length", len) ]) + "p" + |> Request.content_length + with + | Some _ -> false + | None -> true) |> List.for_all Fun.id |> aeb "content_length t = None" true in @@ -59,9 +59,9 @@ let content_length_tests = let method_ () = [ `GET; `HEAD; `DELETE; `OPTIONS; `TRACE; `CONNECT; `Other "h" ] |> List.map (fun meth -> - match Request.make ~meth "p" |> Request.content_length with - | Some _ -> false - | None -> true) + match Request.make ~meth "p" |> Request.content_length with + | Some _ -> false + | None -> true) |> List.for_all Fun.id |> aeb "content_length t = None" true in diff --git a/http/test/test_response.ml b/http/test/test_response.ml index 26154fe..c0e9b29 100644 --- a/http/test/test_response.ml +++ b/http/test/test_response.ml @@ -56,6 +56,32 @@ let content_length_tests = ( "content_length", [ ("OK", `Quick, ok_status); ("`No_content", `Quick, no_content_status) ] ) +let body_allowed_tests = + let case (status, expected) = + ( Status.to_string status, + `Quick, + fun () -> + Status.body_allowed status + |> aeb ("body_allowed " ^ Status.to_string status) expected ) + in + ( "body_allowed", + List.map case + [ + (`Continue, false); + (`Switching_protocols, false); + (`Processing, false); + (`Checkpoint, false); + (`No_content, false); + (`Not_modified, false); + (`Code 199, false); + (`OK, true); + (`Created, true); + (`Found, true); + (`Bad_request, true); + (`Internal_server_error, true); + (`Code 250, true); + ] ) + let () = Alcotest.run "test_response" - [ requires_content_length_tests; content_length_tests ] + [ requires_content_length_tests; content_length_tests; body_allowed_tests ]